Planet Source Code Jumbo …e CD Visual Basic 1 to 7/6_2008-2009.ISO/data/zips/Round_Cala215421642009.psc/new cal/Form1.frm

Text File | 2009-06-02 | 19KB | 602 lines

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Form1
   Caption         =   "Save this"
   ClientHeight    =   12555
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   17040
   LinkTopic       =   "Form1"
   ScaleHeight     =   837
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   1136
   StartUpPosition =   2  'CenterScreen
   WindowState     =   2  'Maximized
   Begin VB.CheckBox Check6
      Caption         =   "Week No"
      Height          =   255
      Left            =   9120
      TabIndex        =   32
      Top             =   840
      Value           =   1  'Checked
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog cd1
      Left            =   11760
      Top             =   720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CheckBox Check5
      Caption         =   "Cutting Line"
      Height          =   255
      Left            =   9120
      TabIndex        =   31
      Top             =   480
      Value           =   1  'Checked
      Width           =   1215
   End
   Begin VB.CheckBox Check4
      Caption         =   "Sun rise/set"
      Height          =   255
      Left            =   10320
      TabIndex        =   30
      Top             =   120
      Width           =   1455
   End
   Begin VB.ComboBox Combo5
      Height          =   315
      Left            =   240
      TabIndex        =   29
      Text            =   "Combo5"
      Top             =   960
      Width           =   855
   End
   Begin VB.ComboBox Text1
      Height          =   315
      Left            =   2040
      TabIndex        =   28
      Text            =   "Combo5"
      Top             =   120
      Width           =   855
   End
   Begin VB.ComboBox Combo4
      Height          =   315
      Left            =   3120
      Sorted          =   -1  'True
      TabIndex        =   27
      Text            =   "Combo2"
      Top             =   600
      Width           =   2775
   End
   Begin VB.ComboBox Combo3
      Height          =   315
      Left            =   6000
      Sorted          =   -1  'True
      TabIndex        =   26
      Text            =   "Combo2"
      Top             =   600
      Width           =   2775
   End
   Begin VB.ComboBox Combo2
      Height          =   315
      Left            =   240
      Sorted          =   -1  'True
      TabIndex        =   25
      Text            =   "Combo2"
      Top             =   600
      Width           =   2775
   End
   Begin VB.CheckBox Check3
      Caption         =   "Include diary"
      Height          =   255
      Left            =   8880
      TabIndex        =   24
      Top             =   120
      Value           =   1  'Checked
      Width           =   1215
   End
   Begin VB.CheckBox Check2
      Caption         =   "Outer ring"
      Height          =   255
      Left            =   7440
      TabIndex        =   23
      Top             =   120
      Width           =   1215
   End
   Begin VB.CheckBox Check1
      Caption         =   "Moon phases"
      Height          =   255
      Left            =   5760
      TabIndex        =   22
      Top             =   120
      Value           =   1  'Checked
      Width           =   1575
   End
   Begin Project1.IoxContainer Iox1
      Height          =   11055
      Left            =   120
      TabIndex        =   20
      Top             =   1440
      Width           =   16815
      _ExtentX        =   29660
      _ExtentY        =   19500
      Begin VB.PictureBox Pic1
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H80000005&
         BeginProperty Font
            Name            =   "Arial"
            Size            =   6
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H80000008&
         Height          =   11895
         Left            =   0
         ScaleHeight     =   791
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   1120
         TabIndex        =   21
         Top             =   0
         Width           =   16830
      End
   End
   Begin VB.CommandButton Command3
      Caption         =   "Save year"
      Height          =   375
      Left            =   4560
      TabIndex        =   19
      Top             =   120
      Width           =   1095
   End
   Begin VB.CommandButton Command2
      Caption         =   "Save this"
      Height          =   375
      Left            =   3360
      TabIndex        =   18
      Top             =   120
      Width           =   1095
   End
   Begin VB.ComboBox Combo1
      Height          =   315
      Left            =   1080
      TabIndex        =   17
      Text            =   "Combo1"
      Top             =   120
      Width           =   855
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H000000FF&
      Height          =   255
      Index           =   15
      Left            =   16560
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   16
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H009504FF&
      Height          =   255
      Index           =   14
      Left            =   16320
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   15
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H00C004FF&
      Height          =   255
      Index           =   13
      Left            =   16080
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   14
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H00FF00FF&
      Height          =   255
      Index           =   12
      Left            =   15840
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   13
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H00FF04B4&
      Height          =   255
      Index           =   11
      Left            =   15600
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   12
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H00FF0000&
      Height          =   255
      Index           =   10
      Left            =   15360
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   11
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H00FF9B04&
      Height          =   255
      Index           =   9
      Left            =   15120
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   10
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H00FFFF00&
      Height          =   255
      Index           =   8
      Left            =   14880
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   9
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H0000FF00&
      Height          =   255
      Index           =   7
      Left            =   14640
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   8
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H0004FF8E&
      Height          =   255
      Index           =   6
      Left            =   14400
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   7
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H0004FFBA&
      Height          =   255
      Index           =   5
      Left            =   14160
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   6
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H0000FFFF&
      Height          =   255
      Index           =   4
      Left            =   13920
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   5
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H0004DAFF&
      Height          =   255
      Index           =   3
      Left            =   13680
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   4
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H0004A7FF&
      Height          =   255
      Index           =   2
      Left            =   13440
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   3
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H000482FF&
      Height          =   255
      Index           =   1
      Left            =   13200
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   2
      Top             =   120
      Width           =   255
   End
   Begin VB.PictureBox picColors
      BackColor       =   &H000000FF&
      Height          =   255
      Index           =   0
      Left            =   12960
      ScaleHeight     =   195
      ScaleWidth      =   195
      TabIndex        =   1
      Top             =   120
      Width           =   255
   End
   Begin VB.CommandButton Command1
      Caption         =   "Draw"
      Height          =   375
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim HasLoaded As Boolean
Dim PI As Double
Dim agDay As Double
Dim xx As Long
Dim yy As Long
Dim lg As Long
Dim trAg As Double
Dim stLg As Double
Dim xad As Long
Dim ndYear As Long
Dim ndMonth As Long
Dim ndfMonth As Long
Dim segP() As POINTAPI
Dim lMoon() As POINTAPI
Dim dMoon() As POINTAPI
Dim gcol As Long
Dim rd As Long, gd As Long, bd As Long
Dim r2 As Long, g2 As Long, b2 As Long
Dim r3 As Long, g3 As Long, b3 As Long
Dim h As Double, h2 As Long, c As Long
Dim lgPD As Long
Dim cc As Long
Dim cc2 As Long
Dim WkN As Long

Private Type RGBset
    Angle As Integer
    R(0 To 15)
    G(0 To 15)
    b(0 To 15)
    Count As Integer
End Type
Dim gradtemp As RGBset

Private Type POINTAPI
        x As Long
        y As Long
End Type


Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function PolyDraw Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, lpbTypes As Byte, ByVal cCount As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function PolylineTo Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, ByVal cCount As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long) As Long
Dim AA2 As New LineGS

Private Type tAppoint
    ID As Long
    Hol_Date As Date
    Comments As String
    Task As Boolean
    Status As Long
End Type

Private hList() As tAppoint

Private Type LOGBRUSH
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
End Type
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Const BS_NULL = 1
Private Const BS_HOLLOW = BS_NULL

Dim FontsAdded As Boolean
Private cSun As clsSunrise

Private Sub DrawWkNo(tYear As Long, tMonth As Long)
Dim cc As Long
Dim cc2 As Long
Dim wkC As Long
Dim nWks As Long
Dim wkP() As POINTAPI
Dim tmpN As Long
Dim MonSun As Single
Dim tLine As Long

For cc = 1 To ndMonth

    If nWks = 0 Then
        tmpN = 8 - Weekday(DateSerial(tYear, tMonth, cc), vbMonday)
        If cc = 1 And tmpN < 7 Then tLine = 1
        'Debug.Print Weekday(DateSerial(tYear, tMonth, cc), vbMonday)
        If cc + tmpN - 1 > ndMonth Then
            tLine = 2
            tmpN = tmpN - (cc + tmpN - ndMonth) + 1
        End If
        tmpN = tmpN * 2 + 1
        ReDim wkP(tmpN)
        wkC = 0

    End If

        If Weekday(DateSerial(tYear, tMonth, cc), vbMonday) = 1 Then
            MonSun = -0.5
        ElseIf Weekday(DateSerial(tYear, tMonth, cc), vbMonday) = 7 Then
            MonSun = -1.5
        Else
            MonSun = -1
        End If

        trAg = ((cc + MonSun) * agDay) * PI / 180
        wkP(tmpN - wkC).x = (lg * stLg + 10) * Cos(trAg) - xad
        wkP(tmpN - wkC).y = (lg * stLg + 10) * Sin(trAg)

        trAg = ((cc + MonSun) * agDay) * PI / 180
        wkP(wkC).x = (lg * stLg + 10 + WkN) * Cos(trAg) - xad
        wkP(wkC).y = (lg * stLg + 10 + WkN) * Sin(trAg)

        wkC = wkC + 1
        nWks = nWks + 1

    If Weekday(DateSerial(tYear, tMonth, cc), vbMonday) = 7 Or cc = ndMonth Then

        If Weekday(DateSerial(tYear, tMonth, cc), vbMonday) = 1 Then
            MonSun = -1
        'ElseIf Weekday(DateSerial(tYear, tMonth, cc), vbMonday) = 7 Then
        '    MonSun = -1.5
        'Else
        '    MonSun = -1
        End If

        trAg = ((cc + 1 + MonSun) * agDay) * PI / 180
        wkP(tmpN - wkC).x = (lg * stLg + 10) * Cos(trAg) - xad
        wkP(tmpN - wkC).y = (lg * stLg + 10) * Sin(trAg)

        trAg = ((cc + 1 + MonSun) * agDay) * PI / 180
        wkP(wkC).x = (lg * stLg + 10 + WkN) * Cos(trAg) - xad
        wkP(wkC).y = (lg * stLg + 10 + WkN) * Sin(trAg)

    'Pic1.ForeColor = RGB(250, 230, 210)
    Pic1.ForeColor = RGB(250, 230, 210)
    Pic1.FillColor = RGB(250, 230, 210)
    Pic1.DrawWidth = 1
    Pic1.DrawStyle = vbTransparent
    Call Polygon(Pic1.hdc, wkP(0), tmpN + 1)
    Pic1.DrawStyle = vbSolid

    For cc2 = 0 To tmpN - 1
        If cc2 = (tmpN - 1) / 2 And tLine = 2 Then
        Else
        AA2.LineGP Pic1.hdc, wkP(cc2).x, wkP(cc2).y, wkP(cc2 + 1).x, wkP(cc2 + 1).y, 0
        End If
    Next
    If tLine <> 1 Then AA2.LineGP Pic1.hdc, wkP(0).x, wkP(0).y, wkP(tmpN).x, wkP(tmpN).y, 0
    tLine = 0
    'Pic1.DrawWidth = 1

'    If Weekday(DateSerial(tYear, tMonth, cc + 1), vbMonday) = 4 Then
'        trAg = ((cc + 0.7) * agDay) * PI / 180
'        xx = (lg * stLg + 13 + WkN / 2) * Cos(trAg) - xad
'        yy = (lg * stLg + 13 + WkN / 2) * Sin(trAg)
'        'Print wk no
'        Pic1.Font = Combo4
'        Pic1.ForeColor = 0
'        Call cFont(Pic1.hdc, Format(DateSerial(tYear, tMonth, cc + 1), "ww", vbMonday, vbFirstJan1), xx, yy - 7, 12, -90 + (ndfMonth * agDay), True)
'    End If
    nWks = 0
    wkC = 0
    Do
    'Debug.Print wkC, wkP(wkC).x, wkP(wkC).y, UBound(wkP), tmpN
    wkC = wkC + 1
    Loop Until wkC = UBound(wkP) + 1
    wkC = 0
    'ReDim wkP(0)
    End If
Next

Pic1.Font = Combo4
Pic1.ForeColor = 0
For cc = 1 To ndMonth
    If Weekday(DateSerial(tYear, tMonth, cc), vbMonday) = 4 Then
        trAg = ((cc + 0.7 - 1) * agDay) * PI / 180
        xx = (lg * stLg + 13 + WkN / 2) * Cos(trAg) - xad
        yy = (lg * stLg + 13 + WkN / 2) * Sin(trAg)
        'Print wk no
        Call cFont(Pic1.hdc, Format(DateSerial(tYear, tMonth, cc), "ww", vbMonday, vbFirstJan1), xx, yy - 7, 12, -90 + (ndfMonth * agDay), True)
    End If
Next
End Sub

Function MoonPhase(dInDate As Date) As Integer
  Dim lD As Long
  Dim dd As Double

  lD = DateDiff("d", "January 1, 2001", dInDate)
  dd = 0.20439731 + lD * 0.03386319269
  lD = Int(dd)
  dd = dd - lD
  lD = 360 * dd
  If lD < 0 Then lD = lD + 360
  lD = lD \ 2
  'lD = lD * 2
  'Debug.Print lD
  'If lD > 179 Then lD = 179 - lD
  MoonPhase = lD * 2

  'Debug.Print 179 - (179 - MoonPhase), MoonPhase
  If MoonPhase > 179 Then MoonPhase = 179 + (179 - MoonPhase)
'  Debug.Print MoonPhase
  'MoonPhase = lD

End Function

Sub FindInfo(TheDate As Date, NumDays As Long)
    'Dim s$, p&, X&, Y As Long, xOff&, yOff&, n&, h&
    Dim tYear As Long
    'Dim NumDays As Long
    Dim tmpDate As Date
    Dim tmpDate2 As Date
    Dim tmpString As String
    Dim TmpEnd As Date
    Dim TmpInter As Long
    Dim TmpNum As String
    Dim oitemTmp As String
    Dim hcc As Long

    hcc = 0
    Erase hList
    ReDim hList(hcc)

    'CanDraw = False
    'NumDays = 60

    Dim oApp As Outlor2 AsFals= Format(ormat(ormat(ormat(ormat(ormat( AsFals= Format(ormat(ormat(ormat(ormat(ormat( AsFals= Format(ormat(ormat(ormat(ormat(ormat( AsFals= Format(ormat(ormat(ormat(ormat(ormat( AsFals= Format(ormat(ormat(ormat(ormat(ormat
  Dim lD As Longormat
  Dim lD Adc,ThenRSUkC 4mat(ormat(o FormattttttttttttttttmDaysmDayDim lD Adc,ThenRSUkC 4mat(ormat(o Formatttttttttong
Dim AA2 As New LineGS

Private Type tAppoint
    ID As Long
    Hol_Date As mate Type tAppoint8wtA" (lpLogFong
    Hol_Date Asa"cs    Ne,ligmls= Fo